home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / stklos-demo2.stklos < prev    next >
Encoding:
Text File  |  1996-07-21  |  1.9 KB  |  60 lines
  1. #!/usr/local/bin/stk -f
  2. ;;;;
  3. ;;;; s t k l o s - d e m o 2 . s t k       --  A demo which use some STklos classes
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;;
  15. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  16. ;;;;    Creation date: 24-Aug-1993 19:55
  17. ;;;; Last file update: 21-Jul-1996 11:44
  18.  
  19. (require "Tk-classes")
  20.  
  21. (format #t "
  22. This demo file illustrates the use of bind-for-dragging with various 
  23. parameters. 
  24.  
  25. Left button to drag any kind of object
  26. Left button with Shift key pressed to drag an object and executes user hooks
  27. Right button to move red objects only.\n")
  28.  
  29.  
  30. (define c (make <Canvas> :border-width 0))
  31. (pack c)
  32.  
  33.  
  34. (define r1 (make <rectangle> :coords '(0 0 50 50) 
  35.                   :parent c 
  36.                  :fill "red"
  37.                  :tags "red"))
  38. (define r2 (make <rectangle> :coords '(100 100 150 150) 
  39.                   :parent c 
  40.                   :fill "blue"))
  41. (define t  (make <Text-Item> :coords '(80 80) 
  42.                   :parent c 
  43.                  :fill "red"
  44.                  :tags "red"
  45.                  :text "Hello world!"))
  46.  
  47. ;; Button 1 for dragging objects
  48. (bind-for-dragging c)
  49.  
  50. ;; Button 1 for dragging objects (with user hooks)
  51. (bind-for-dragging c :tag 'all
  52.              :modifier "Shift"
  53.              :start  (lambda (w x y) (format #t "Start to drag ~S\n" w))
  54.              :motion (lambda (w x y) (format #t "Move ~A ~A\n" x y))
  55.              :stop   (lambda (w x y) (format #t "Stop with ~S\n" w)))
  56.  
  57. ;; Button 3 for dragging red objects (i.e. r1 and t)
  58. (bind-for-dragging c :tag "red" :button 3)
  59.  
  60.